home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tl / tl-str.el.z / tl-str.el
Encoding:
Text File  |  1998-05-21  |  6.6 KB  |  311 lines
  1. ;;; tl-str.el --- Emacs Lisp Library module about string
  2.  
  3. ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; Version: $Id: tl-str.el,v 7.18 1997/01/14 06:38:49 morioka Exp $
  7. ;; Keywords: string
  8.  
  9. ;; This file is part of tl (Tiny Library).
  10.  
  11. ;; This program is free software; you can redistribute it and/or
  12. ;; modify it under the terms of the GNU General Public License as
  13. ;; published by the Free Software Foundation; either version 2, or (at
  14. ;; your option) any later version.
  15.  
  16. ;; This program is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Code:
  27.  
  28. (require 'emu)
  29. (require 'tl-list)
  30.  
  31.  
  32. ;;; @ converter
  33. ;;;
  34.  
  35. (defun expand-char-ranges (str)
  36.   (let ((i 0)
  37.     (len (length str))
  38.     chr pchr nchr
  39.     (dest ""))
  40.     (while (< i len)
  41.       (setq chr (elt str i))
  42.       (cond ((and pchr (eq chr ?-))
  43.          (setq pchr (1+ pchr))
  44.          (setq i (1+ i))
  45.          (setq nchr (elt str i))
  46.          (while (<= pchr nchr)
  47.            (setq dest (concat dest (char-to-string pchr)))
  48.            (setq pchr (1+ pchr))
  49.            )
  50.          )
  51.         (t
  52.          (setq dest (concat dest (char-to-string chr)))
  53.          ))
  54.       (setq pchr chr)
  55.       (setq i (1+ i))
  56.       )
  57.     dest))
  58.  
  59.  
  60. ;;; @ space
  61. ;;;
  62.  
  63. (defun eliminate-top-spaces (str)
  64.   "Eliminate top sequence of space or tab and return it. [tl-str.el]"
  65.   (if (string-match "^[ \t]+" str)
  66.       (substring str (match-end 0))
  67.     str))
  68.  
  69. (defun eliminate-last-spaces (str)
  70.   "Eliminate last sequence of space or tab and return it. [tl-str.el]"
  71.   (if (string-match "[ \t]+$" str)
  72.       (substring str 0 (match-beginning 0))
  73.     str))
  74.  
  75. (defun replace-space-with-underline (str)
  76.   (mapconcat (function
  77.           (lambda (arg)
  78.         (char-to-string
  79.          (if (eq arg ?\ )
  80.              ?_
  81.            arg)))) str "")
  82.   )
  83.  
  84.  
  85. ;;; @ version
  86. ;;;
  87.  
  88. (defun version-to-list (str)
  89.   (if (string-match "[0-9]+" str)
  90.       (let ((dest
  91.          (list
  92.           (string-to-number
  93.            (substring str (match-beginning 0)(match-end 0))
  94.            ))))
  95.     (setq str (substring str (match-end 0)))
  96.     (while (string-match "^\\.[0-9]+" str)
  97.       (setq dest
  98.         (cons
  99.          (string-to-number
  100.           (substring str (1+ (match-beginning 0))(match-end 0)))
  101.          dest))
  102.       (setq str (substring str (match-end 0)))
  103.       )
  104.     (nreverse dest)
  105.     )))
  106.  
  107. (defun version< (v1 v2)
  108.   (or (listp v1)
  109.       (setq v1 (version-to-list v1))
  110.       )
  111.   (or (listp v2)
  112.       (setq v2 (version-to-list v2))
  113.       )
  114.   (catch 'tag
  115.     (while (and v1 v2)
  116.       (cond ((< (car v1)(car v2))
  117.          (throw 'tag v2)
  118.          )
  119.         ((> (car v1)(car v2))
  120.          (throw 'tag nil)
  121.          ))
  122.       (setq v1 (cdr v1)
  123.         v2 (cdr v2))
  124.       )
  125.     v2))
  126.  
  127. (defun version<= (v1 v2)
  128.   (or (listp v1)
  129.       (setq v1 (version-to-list v1))
  130.       )
  131.   (or (listp v2)
  132.       (setq v2 (version-to-list v2))
  133.       )
  134.   (catch 'tag
  135.     (while (and v1 v2)
  136.       (cond ((< (car v1)(car v2))
  137.          (throw 'tag v2)
  138.          )
  139.         ((> (car v1)(car v2))
  140.          (throw 'tag nil)
  141.          ))
  142.       (setq v1 (cdr v1)
  143.         v2 (cdr v2))
  144.       )
  145.     (or v2 (and (null v1)(null v2)))
  146.     ))
  147.  
  148. (defun version> (v1 v2)
  149.   (or (listp v1)
  150.       (setq v1 (version-to-list v1))
  151.       )
  152.   (or (listp v2)
  153.       (setq v2 (version-to-list v2))
  154.       )
  155.   (catch 'tag
  156.     (while (and v1 v2)
  157.       (cond ((> (car v1)(car v2))
  158.          (throw 'tag v1)
  159.          )
  160.         ((< (car v1)(car v2))
  161.          (throw 'tag nil)
  162.          ))
  163.       (setq v1 (cdr v1)
  164.         v2 (cdr v2))
  165.       )
  166.     v1))
  167.  
  168. (defun version>= (v1 v2)
  169.   (or (listp v1)
  170.       (setq v1 (version-to-list v1))
  171.       )
  172.   (or (listp v2)
  173.       (setq v2 (version-to-list v2))
  174.       )
  175.   (catch 'tag
  176.     (while (and v1 v2)
  177.       (cond ((> (car v1)(car v2))
  178.          (throw 'tag v1)
  179.          )
  180.         ((< (car v1)(car v2))
  181.          (throw 'tag nil)
  182.          ))
  183.       (setq v1 (cdr v1)
  184.         v2 (cdr v2))
  185.       )
  186.     (or v1 (and (null v1)(null v2)))
  187.     ))
  188.  
  189.  
  190. ;;; @ RCS version
  191. ;;;
  192.  
  193. (defun get-version-string (id)
  194.   "Return a version-string from RCS ID. [tl-str.el]"
  195.   (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id)
  196.        (substring id (match-beginning 1)(match-end 1))
  197.        ))
  198.  
  199.  
  200. ;;; @ file name
  201. ;;;
  202.  
  203. (defun file-name-non-extension (filename)
  204.   (if (string-match "\\.[^.]+$" filename)
  205.       (substring filename 0 (match-beginning 0))
  206.     filename))
  207.  
  208. (autoload 'replace-as-filename "filename"
  209.   "Return safety filename from STRING.")
  210.  
  211.  
  212. ;;; @ symbol
  213. ;;;
  214.  
  215. (defun symbol-concat (&rest args)
  216.   "Return a symbol whose name is concatenation of arguments ARGS
  217. which are string or symbol. [tl-str.el]"
  218.   (intern (apply (function concat)
  219.          (mapcar (function
  220.               (lambda (s)
  221.                 (cond ((symbolp s) (symbol-name s))
  222.                   ((stringp s) s)
  223.                   )
  224.                 ))
  225.              args)))
  226.   )
  227.  
  228.  
  229. ;;; @ matching
  230. ;;;
  231.  
  232. (defun top-string-match (pat str)
  233.   "Return a list (MATCHED REST) if string PAT is top substring of
  234. string STR. [tl-str.el]"
  235.   (if (string-match
  236.        (concat "^" (regexp-quote pat))
  237.        str)
  238.       (list pat (substring str (match-end 0)))
  239.     ))
  240.  
  241. (defun middle-string-match (pat str)
  242.   "Return a list (PREVIOUS MATCHED REST) if string PAT is found in
  243. string STR. [tl-str.el]"
  244.   (if (equal pat str)
  245.       (list nil pat nil)
  246.     (if (string-match (regexp-quote pat) str)
  247.     (let ((b (match-beginning 0))
  248.           (e (match-end 0)) )
  249.       (list (if (not (= b 0))
  250.             (substring str 0 b)
  251.           )
  252.         pat
  253.         (if (> (length str) e)
  254.             (substring str e)
  255.           )
  256.         )))))
  257.  
  258. (defun re-top-string-match (pat str)
  259.   "Return a list (MATCHED REST) if regexp PAT is matched as top
  260. substring of string STR. [tl-str.el]"
  261.   (if (string-match (concat "^" pat) str)
  262.       (let ((e (match-end 0)))
  263.     (list (substring str 0 e)(substring str e))
  264.     )))
  265.  
  266.  
  267. ;;; @ compare
  268. ;;;
  269.  
  270. (defun string-compare-from-top (str1 str2)
  271.   (let* ((len1 (length str1))
  272.      (len2 (length str2))
  273.      (len (min len1 len2))
  274.      (p 0)
  275.      c1 c2)
  276.     (while (and (< p len)
  277.         (progn
  278.           (setq c1 (sref str1 p)
  279.             c2 (sref str2 p))
  280.           (eq c1 c2)
  281.           ))
  282.       (setq p (+ p (char-length c1)))
  283.       )
  284.     (and (> p 0)
  285.      (let ((matched (substring str1 0 p))
  286.            (r1 (and (< p len1)(substring str1 p)))
  287.            (r2 (and (< p len2)(substring str2 p)))
  288.            )
  289.        (if (eq r1 r2)
  290.            matched
  291.          (list 'seq matched (list 'or r1 r2))
  292.          )))))
  293.  
  294.  
  295. ;;; @ regexp
  296. ;;;
  297.  
  298. (defun regexp-* (regexp)
  299.   (concat regexp "*"))
  300.  
  301. (defun regexp-or (&rest args)
  302.   (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
  303.  
  304.  
  305. ;;; @ end
  306. ;;;
  307.  
  308. (provide 'tl-str)
  309.  
  310. ;;; tl-str.el ends here
  311.